Milestone #4

Milestone #4

Map of New Infections by County

# map of new infections by county

ca_counties <- map_data("county") %>%
  filter(region == "california")

stratified_rate_infections_lower <- stratified_rate_infections %>%
  mutate(county = str_to_lower(county))

map_data <- ca_counties %>%
  left_join(stratified_rate_infections_lower, by = c("subregion" = "county"))

# map

long_caption <- "The map shows that Imperial County has the highest new infections in 2023. It appears that the coastal counties may have a lower rate of new infections."
wrapped_caption <- str_wrap(long_caption, width = 50) 

       

ggplot(map_data, aes(long, lat, group = group, fill = new_infections_per_capita)) +
  geom_polygon(color = "white") +
  scale_fill_viridis_c(option = "magma", limits = c(0,50), na.value = "grey") +
  labs(title = "Heat Map of New Infections per Capita by County, 2023", fill = "Infection Rate", caption = wrapped_caption) +
  theme_void() + 
  theme(
  plot.title = element_text(hjust = 0.5, margin = margin(b = 10)),
  legend.position = "right",
  legend.title = element_text(size = 10),
  legend.text = element_text(size = 8),
  plot.margin = margin(t = 20, r = 20, b = 20, l = 20)
)

Table of Infections Per Capita per Race/Ethnicity and County

race_infections_table <- race_infections_clean %>%

select(County, `American Indian or Alaska Native Non-Hispanic`, `Asian Non-Hispanic’, Black Non-Hispanic`, `Hispanic (Any Race)`, `Multiracial (Two or More Above Races)`, `Total Infections per Capita per County`)

(

“American Indian or Alaska Native (Non-Hispanic)”,

“Asian (Non-Hispanic)”,

“Black (Non-Hispanic)”,

“Hispanic (Any Race)”,

“Multiracial (Two or More of Above Races)”,

“Native Hawaiian or Pacific Islander (Non-Hispanic)”

“White (Non-Hispanic)”

)

race_infections_table,

options = list(

pageLength = 15,

scrollX = TRUE,

autoWidth = TRUE

)

) %>%

formatStyle(

columns = 2,

valueColumns = 2,

color = styleEqual(race_infections_table\[8, 2\], ‘red’)

) %>%

formatStyle(

columns = 8,

valueColumns = 8,

color = styleEqual(race_infections_table\[8, 8\], ‘red’)

)

#Reformatting df for Table 

race_infections_clean <- stratified_rate_infections %>%
  pivot_wider(
    id_cols = county,
    names_from = race_ethnicity,
    values_from = c("new_infections_per_capita", "pop")
  )

#Renaming columns 

colnames(race_infections_clean) <- c("County", "American Indian or Alaska Native (Non-Hispanic)", "Asian (Non-Hispanic)", "Black (Non-Hispanic)", "Hispanic (Any Race)", "Multiracial (Two or More of Above Races)", "Native Hawaiian or Pacific Islander (Non-Hispanic)", "White (Non-Hispanic)", "American Indian or Alaska Native (Non-Hispanic) Pop", "Asian (Non-Hispanic) Pop",  "Black (Non-Hispanic) Pop", "Hispanic (Any Race) Pop", "Multiracial (Two or More of Above Races) Pop", "Native Hawaiian or Pacific Islander (Non-Hispanic) Pop", "White (Non-Hispanic) Pop")

#Adding Total per Capita for each Race/Ethnic Group Category

race_group <- c(
  "American Indian or Alaska Native (Non-Hispanic)",
  "Asian (Non-Hispanic)",
  "Black (Non-Hispanic)",
  "Hispanic (Any Race)",
  "Multiracial (Two or More of Above Races)",
  "Native Hawaiian or Pacific Islander (Non-Hispanic)",
  "White (Non-Hispanic)"
)

race_sum <- race_infections_clean %>%
  summarise(across(all_of(race_group), ~ sum(.x, na.rm = TRUE))) %>%
  mutate(County = "Total per each Race/Ethnic Group")

race_infections_clean <- bind_rows(race_infections_clean, race_sum)

#Rearranging and Select the columns 

race_infections_table <- race_infections_clean %>%
  select(County, `American Indian or Alaska Native (Non-Hispanic)`, `Asian (Non-Hispanic)`, `Black (Non-Hispanic)`, `Hispanic (Any Race)`, `Multiracial (Two or More of Above Races)`, `Native Hawaiian or Pacific Islander (Non-Hispanic)`, `White (Non-Hispanic)`
)

#Creating Table Visualization

#Adding Bolded Values and Color
datatable(
  race_infections_table,
  options = list(
    pageLength = 15,
    scrollX = TRUE,
    autoWidth = TRUE
  ),
  caption = "Rate of Infections per Capita by Race and Ethnic Group per County"
) %>%
  formatRound(columns = 2:ncol(race_infections_table), digits = 2) %>%
  formatStyle(1,color="darkgreen") %>%
  formatStyle(
    columns = c(2, 8),
    fontWeight = 'bold'
  )

#Table Description: "American Indian or Alaska Native (Non-Hispanic) and White (Non-Hispanic) racial and ethnic groups have the highest per capita rates in total in California. "

Time trends of infections

# re-stratify datasets by epi week
epiweek_morbidity_infections <- morbidity_combined %>% 
  group_by(age_category,diagnosis_date) %>% 
  summarise("new_infections" = sum(new_infections),
            "new_severe" = sum(new_severe)) %>% 
  ungroup()

## `summarise()` has grouped output by 'age_category'. You can override using the
## `.groups` argument.

age_ca_pop <- ca_pop_clean %>%
  group_by(age_category) %>% 
  summarize(pop = sum(pop)) %>% 
  ungroup()

# join age datasets together
epiweek_age_joined <- left_join(epiweek_morbidity_infections,
                              age_ca_pop, 
                              by = c("age_category"))

# calculate infection rates per 100 ppl for epiweek/race groups
epiweek_rates <- epiweek_age_joined %>% 
  mutate(new_inf_rate = round((new_infections/pop)*1000, digits=3),
         new_severe_rate = round((new_severe/pop)*1000,digits=3))

# graph
epiweek_new_plot <- plot_ly(
  epiweek_rates,
  x = ~diagnosis_date,
  y = ~new_inf_rate,
  type = 'scatter',
  mode = 'lines',
  color = ~age_category,
  legendgroup = "age",
  showlegend = TRUE
)

epiweek_severe_plot <- plot_ly(
  epiweek_rates,
  x = ~diagnosis_date,
  y = ~new_severe_rate,
  type = 'scatter',
  mode = 'lines',
  color = ~age_category,
  legendgroup = "age",
  showlegend = FALSE
)

epiweek_plot <- subplot(
  epiweek_new_plot,
  epiweek_severe_plot,
  nrows = 1,
  shareX = TRUE,
  titleY = FALSE,
  titleX = FALSE
) %>%
  layout(title = list(
      text = "New and Severe Case Rates by Age",
      x = 0.45, y=1.2,
      xanchor = "center",
      font = list(size = 16, color = "black")
    ),
    annotations = list(
      list(x = 0.15, y = 1.05, text = "New Infections", 
           xref = "paper", yref = "paper", showarrow = FALSE),
      list(x = 0.85, y = 1.05, text = "New Severe Infections", 
           xref = "paper", yref = "paper", showarrow = FALSE),
      list(x = 0.5, y = -0.2,
           text = "Infection rates are highest between early August to late October.<br>Both new and severe infection rates are highest among those aged 65+.",
           xref = "paper", yref = "paper", showarrow = FALSE)
    ),
    margin = list(t = 70, b = 90),
    yaxis = list(title = "Cases per 1000 people"),
    xaxis = list(zeroline = FALSE),
    legend = list(title = list(text = "Age")),
    plot_bgcolor = '#e5ecf6'
  )

epiweek_plot